home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / gnat-3.05- / gnat-3 / gnat-3.05-i486-linux-elf-bin / rts / i-cpp.adb < prev    next >
Encoding:
Text File  |  1996-06-07  |  9.7 KB  |  312 lines

  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       I N T E R F A C E S . C P P                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.10 $                              --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Ada.Tags;                use Ada.Tags;
  37. with Interfaces.C;            use Interfaces.C;
  38. with System;                  use System;
  39. with System.Storage_Elements; use System.Storage_Elements;
  40. with Unchecked_Conversion;
  41.  
  42. package body Interfaces.CPP is
  43.  
  44.    subtype Cstring is String (Positive);
  45.    type Cstring_Ptr is access all Cstring;
  46.    type Tag_Table is array (Natural range <>) of Vtable_Ptr;
  47.  
  48.    type Type_Specific_Data is record
  49.       Idepth        : Natural;
  50.       Expanded_Name : Cstring_Ptr;
  51.       External_Tag  : Cstring_Ptr;
  52.       HT_Link       : Tag;
  53.       Ancestor_Tags : Tag_Table (Natural);
  54.    end record;
  55.  
  56.    type Vtable_Entry is record
  57.      Delta1 : C.Short;
  58.      Index  : C.Short;
  59.      Pfn    : System.Address;
  60.    end record;
  61.  
  62.    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
  63.    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  64.  
  65.    type VTable is record
  66.       Unused1   : C.Short;
  67.       Unused2   : C.Short;
  68.       TSD       : Type_Specific_Data_Ptr;
  69.       Prims_Ptr : Vtable_Entry_Array (Positive);
  70.    end record;
  71.  
  72.    --------------------------------------------------------
  73.    -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
  74.    --------------------------------------------------------
  75.  
  76.    function To_Type_Specific_Data_Ptr is
  77.      new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
  78.  
  79.    function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address);
  80.    function To_Address is
  81.      new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
  82.  
  83.    function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr);
  84.    function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag);
  85.  
  86.    ---------------------------------------------
  87.    -- Unchecked Conversions for String Fields --
  88.    ---------------------------------------------
  89.  
  90.    function To_Cstring_Ptr is
  91.      new Unchecked_Conversion (Address, Cstring_Ptr);
  92.  
  93.    function To_Address is
  94.      new Unchecked_Conversion (Cstring_Ptr, Address);
  95.  
  96.    -----------------------
  97.    -- Local Subprograms --
  98.    -----------------------
  99.  
  100.    function Length (Str : Cstring_Ptr) return Natural;
  101.    --  Length of string represented by the given pointer (treating the
  102.    --  string as a C-style string, which is Nul terminated).
  103.  
  104.    --------------------
  105.    -- Displaced_This --
  106.    --------------------
  107.  
  108.    function Displaced_This
  109.     (Current_This : System.Address;
  110.      Vptr         : Vtable_Ptr;
  111.      Position     : Positive)
  112.      return         System.Address
  113.    is
  114.    begin
  115.       return Current_This
  116.         + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
  117.    end Displaced_This;
  118.  
  119.    -----------------------
  120.    -- CPP_CW_Membership --
  121.    -----------------------
  122.  
  123.    function CPP_CW_Membership
  124.      (Obj_Tag : Vtable_Ptr;
  125.       Typ_Tag : Vtable_Ptr)
  126.       return Boolean
  127.    is
  128.       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
  129.    begin
  130.       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
  131.    end CPP_CW_Membership;
  132.  
  133.    ---------------------------
  134.    -- CPP_Get_Expanded_Name --
  135.    ---------------------------
  136.  
  137.    function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
  138.    begin
  139.       return To_Address (T.TSD.Expanded_Name);
  140.    end CPP_Get_Expanded_Name;
  141.  
  142.    --------------------------
  143.    -- CPP_Get_External_Tag --
  144.    --------------------------
  145.  
  146.    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
  147.    begin
  148.       return To_Address (T.TSD.External_Tag);
  149.    end CPP_Get_External_Tag;
  150.  
  151.    -------------------------------
  152.    -- CPP_Get_Inheritance_Depth --
  153.    -------------------------------
  154.  
  155.    function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
  156.    begin
  157.       return T.TSD.Idepth;
  158.    end CPP_Get_Inheritance_Depth;
  159.  
  160.    -------------------------
  161.    -- CPP_Get_Prim_Op_Address --
  162.    -------------------------
  163.  
  164.    function CPP_Get_Prim_Op_Address
  165.      (T        : Vtable_Ptr;
  166.       Position : Positive)
  167.       return Address is
  168.    begin
  169.       return T.Prims_Ptr (Position).Pfn;
  170.    end CPP_Get_Prim_Op_Address;
  171.  
  172.    -----------------
  173.    -- CPP_Get_TSD --
  174.    -----------------
  175.  
  176.    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
  177.    begin
  178.       return To_Address (T.TSD);
  179.    end CPP_Get_TSD;
  180.  
  181.    --------------------
  182.    -- CPP_Inherit_DT --
  183.    --------------------
  184.  
  185.    procedure CPP_Inherit_DT
  186.     (Old_T   : Vtable_Ptr;
  187.      New_T   : Vtable_Ptr;
  188.      Entry_Count : Natural)
  189.    is
  190.    begin
  191.       if Old_T /= null then
  192.          New_T.Prims_Ptr (1 .. Entry_Count)
  193.            := Old_T.Prims_Ptr (1 .. Entry_Count);
  194.       end if;
  195.    end CPP_Inherit_DT;
  196.  
  197.    ---------------------
  198.    -- CPP_Inherit_TSD --
  199.    ---------------------
  200.  
  201.    procedure CPP_Inherit_TSD
  202.      (Old_TSD : Address;
  203.       New_Tag : Vtable_Ptr)
  204.    is
  205.       TSD : constant Type_Specific_Data_Ptr
  206.         := To_Type_Specific_Data_Ptr (Old_TSD);
  207.  
  208.       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
  209.  
  210.    begin
  211.       if TSD /= null then
  212.          New_TSD.Idepth := TSD.Idepth + 1;
  213.          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
  214.            := TSD.Ancestor_Tags (0 .. TSD.Idepth);
  215.       else
  216.          New_TSD.Idepth := 0;
  217.       end if;
  218.  
  219.       New_TSD.Ancestor_Tags (0) := New_Tag;
  220.    end CPP_Inherit_TSD;
  221.  
  222.    ---------------------------
  223.    -- CPP_Set_Expanded_Name --
  224.    ---------------------------
  225.  
  226.    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
  227.    begin
  228.       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
  229.    end CPP_Set_Expanded_Name;
  230.  
  231.    --------------------------
  232.    -- CPP_Set_External_Tag --
  233.    --------------------------
  234.  
  235.    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
  236.    begin
  237.       T.TSD.External_Tag := To_Cstring_Ptr (Value);
  238.    end CPP_Set_External_Tag;
  239.  
  240.    -------------------------------
  241.    -- CPP_Set_Inheritance_Depth --
  242.    -------------------------------
  243.  
  244.    procedure CPP_Set_Inheritance_Depth
  245.      (T     : Vtable_Ptr;
  246.       Value : Natural)
  247.    is
  248.    begin
  249.       T.TSD.Idepth := Value;
  250.    end CPP_Set_Inheritance_Depth;
  251.  
  252.    -----------------------------
  253.    -- CPP_Set_Prim_Op_Address --
  254.    -----------------------------
  255.  
  256.    procedure CPP_Set_Prim_Op_Address
  257.      (T        : Vtable_Ptr;
  258.       Position : Positive;
  259.       Value    : Address)
  260.    is
  261.    begin
  262.       T.Prims_Ptr (Position).Pfn := Value;
  263.    end CPP_Set_Prim_Op_Address;
  264.  
  265.    -----------------
  266.    -- CPP_Set_TSD --
  267.    -----------------
  268.  
  269.    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
  270.    begin
  271.       T.TSD := To_Type_Specific_Data_Ptr (Value);
  272.    end CPP_Set_TSD;
  273.  
  274.    -------------------
  275.    -- Expanded_Name --
  276.    -------------------
  277.  
  278.    function Expanded_Name (T : Vtable_Ptr) return String is
  279.       Result : Cstring_Ptr := T.TSD.Expanded_Name;
  280.  
  281.    begin
  282.       return Result (1 .. Length (Result));
  283.    end Expanded_Name;
  284.  
  285.    ------------------
  286.    -- External_Tag --
  287.    ------------------
  288.  
  289.    function External_Tag (T : Vtable_Ptr) return String is
  290.       Result : Cstring_Ptr := T.TSD.External_Tag;
  291.  
  292.    begin
  293.       return Result (1 .. Length (Result));
  294.    end External_Tag;
  295.  
  296.    ------------
  297.    -- Length --
  298.    ------------
  299.  
  300.    function Length (Str : Cstring_Ptr) return Natural is
  301.       Len : Integer := 1;
  302.  
  303.    begin
  304.       while Str (Len) /= Ascii.Nul loop
  305.          Len := Len + 1;
  306.       end loop;
  307.  
  308.       return Len - 1;
  309.    end Length;
  310.  
  311. end Interfaces.CPP;
  312.